home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / prefsHandling.tcl < prev    next >
Encoding:
Text File  |  2000-11-29  |  13.2 KB  |  521 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AlphaTcl - core Tcl engine
  4.  # 
  5.  #  FILE: "prefsHandling.tcl"
  6.  #                                    created: 24/2/95 {9:52:30 pm} 
  7.  #                                last update: 11/29/2000 {10:44:06 AM} 
  8.  #  
  9.  # Reorganisation carried out by Vince Darley with much help from Tom 
  10.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  11.  # Alpha is shareware; please register with the author using the register 
  12.  # button in the about box.
  13.  #  
  14.  #  Description: 
  15.  # 
  16.  # Procedures for dealing with the user's preferences
  17.  # ###################################################################
  18.  ##
  19.  
  20. proc viewValue {name val} {
  21.     set header "'$name's value is:"
  22.     set response "\r$val\r"
  23.     if {[string length $val] > 80} {
  24.     if {![catch {llength $val}] && (([llength $val] > 3) && ([llength $val] > 6 || [string length $val] > 160))} {
  25.         listpick -p "'$name's value is:" $val
  26.     } else {
  27.         if {[tclLog $header$response]} {
  28.         global tileLeft tileTop tileWidth
  29.         new -g $tileLeft $tileTop $tileWidth 100 -n "* $name *" -m Text \
  30.           -info "'$name's value is:\r\r$val\r"
  31.         }
  32.     }
  33.     } else {
  34.     global mode
  35.     if {$mode == "Shel"} {
  36.         goto [maxPos]
  37.         tclLog $header$response
  38.         insertText [Alpha::Prompt]
  39.     } else {
  40.         alertnote "$header\r$response"
  41.     }
  42.     }
  43. }
  44.  
  45. namespace eval prefs {}
  46.  
  47. ## 
  48.  # -------------------------------------------------------------------------
  49.  # 
  50.  # "prefs::modified" --
  51.  # 
  52.  #  Accepts either scalar or array variables, which must have a complete
  53.  #  namespace specification (i.e. they are not calling-namespace-relative).
  54.  #  
  55.  #  Adds the given variables to the list of things to save when the
  56.  #  user 'quits' (or elects to 'save preferences now').
  57.  # -------------------------------------------------------------------------
  58.  ##
  59. proc prefs::modified {args} {
  60.     global modifiedVars modifiedArrayElements
  61.     foreach what $args {
  62.     if {[regexp {([^(]+)\(([^)]+)\)} $what "" arr var]} {
  63.         lappend modifiedArrayElements [list $var $arr]
  64.     } else {
  65.         lappend modifiedVars $what
  66.     }
  67.     }
  68. }
  69.  
  70. ## 
  71.  # -------------------------------------------------------------------------
  72.  # 
  73.  # "prefs::removeObsolete" --
  74.  # 
  75.  #  Use this only for preference variables which are truly obsolete,
  76.  #  and never referenced in code.  It 'unsets' the variables, so that
  77.  #  accessing them again will cause errors.  To forget a users preference
  78.  #  for something (so that it reverts to a default value), you should
  79.  #  use 'prefs::remove' or 'prefs::removeArrayElement' (both of which
  80.  #  can only take effect after a restart).
  81.  # -------------------------------------------------------------------------
  82.  ##
  83. proc prefs::removeObsolete {args} {
  84.     set count 0
  85.     foreach what $args {
  86.     if {[uplevel \#0 info exists [list $what]]} {
  87.         prefs::modified $what
  88.         uplevel \#0 unset [list $what]
  89.         incr count
  90.     }
  91.     }
  92.     return $count
  93. }
  94.  
  95. ## 
  96.  # -------------------------------------------------------------------------
  97.  # 
  98.  # "prefs::renameOld" --
  99.  # 
  100.  #  Useful to allow authors to rename preferences variables without
  101.  #  inconveniencing their users.  Returns 1 if a renaming did take
  102.  #  place (this allows the author to take an action such as telling the
  103.  #  user).
  104.  # -------------------------------------------------------------------------
  105.  ##
  106. proc prefs::renameOld {from to} {
  107.     if {[uplevel \#0 info exists [list $from]]} {
  108.     prefs::modified $from
  109.     prefs::modified $to
  110.     uplevel \#0 set [list $to [uplevel \#0 set [list $from]]]
  111.     uplevel \#0 unset [list $from]
  112.     return 1
  113.     } else {
  114.     return 0
  115.     }
  116. }
  117.  
  118. proc prefs::modifiedVar {args} {
  119.     global modifiedVars
  120.     eval lappend modifiedVars $args
  121. }
  122.  
  123. proc prefs::modifiedModeVar {var {m ""}} {
  124.     global modifiedArrayElements mode
  125.     if {$m == ""} { set m $mode }
  126.     lappend modifiedArrayElements [list $var ${m}modeVars]
  127. }
  128.  
  129. proc prefs::modifiedArrayElement {var arr} {
  130.     global modifiedArrayElements
  131.     lappend modifiedArrayElements [list $var $arr]
  132. }
  133.  
  134. proc prefs::add {def val {prefix {}}} {
  135.     global ${prefix}prefDefs
  136.     
  137.     prefs::_read $prefix
  138.     set ${prefix}prefDefs($def) $val
  139.     prefs::_write $prefix
  140.     catch {unset ${prefix}prefDefs}
  141. }
  142.  
  143. proc prefs::remove {def {prefix {}}} {
  144.     global ${prefix}prefDefs
  145.     
  146.     prefs::_read $prefix
  147.     catch {unset ${prefix}prefDefs($def)}
  148.     prefs::_write $prefix
  149.     catch {unset ${prefix}prefDefs}
  150. }
  151.  
  152. proc prefs::addArrayElement {arr def val} {
  153.     prefs::add [list $arr $def] $val arr
  154. }
  155.  
  156. proc prefs::removeArrayElement {arr def} {
  157.     prefs::remove [list $arr $def] arr
  158. }
  159.  
  160. proc prefs::removeArray {arr} {
  161.     global arrprefDefs $arr
  162.     
  163.     prefs::_read arr
  164.     foreach def [array names $arr] {
  165.     catch {unset arrprefDefs([list $arr $def])}
  166.     }
  167.     prefs::_write arr
  168.     catch {unset arrprefDefs}
  169. }
  170.  
  171. proc prefs::addArray {arr} {
  172.     global arrprefDefs $arr
  173.     
  174.     prefs::_read arr
  175.     # Remove all old entries.  We have to do this because the
  176.     # code just after will only update existing entries, so old
  177.     # array elements which we no longer want will never disappear.
  178.     foreach r [array names arrprefDefs] {
  179.     if {[lindex $r 0] == $arr} {
  180.         unset arrprefDefs($r)
  181.     }
  182.     }
  183.     foreach def [array names $arr] {
  184.     catch {set arrprefDefs([list $arr $def]) [set ${arr}($def)]}
  185.     }
  186.     prefs::_write arr
  187.     catch {unset arrprefDefs}
  188. }
  189.  
  190. proc prefs::_read {{prefix {}}} {
  191.     global PREFS
  192.     if {![file exists [file join $PREFS ${prefix}defs.tcl]]} return
  193.     uplevel \#0 [list source [file join $PREFS ${prefix}defs.tcl]]
  194. }
  195.  
  196. proc prefs::_write {{prefix {}}} {
  197.     global PREFS ${prefix}prefDefs 
  198.     
  199.     if {![info exists ${prefix}prefDefs]} {
  200.     catch {file delete [file join $PREFS ${prefix}defs.tcl]}
  201.     return
  202.     }
  203.     
  204.     if {![file exists "$PREFS"]} {
  205.     file mkdir "$PREFS"
  206.     }
  207.     set fd [alphaOpen [file join $PREFS ${prefix}defs.tcl] "w"]
  208.     foreach nm [array names ${prefix}prefDefs] {
  209.     puts $fd [list set ${prefix}prefDefs($nm) [set ${prefix}prefDefs($nm)]]
  210.     }
  211.     close $fd
  212. }
  213.  
  214.  
  215. # So we are picked up by standard auto_mkindex
  216. proc prefs::readAll {} {}
  217.  
  218. if {[info tclversion] < 8.0} {
  219.     proc prefs::readAll {} {
  220.     global prefDefs arrprefDefs PREFS
  221.     
  222.     if {[file exists [file join $PREFS defs.tcl]]} {
  223.         source [file join $PREFS defs.tcl]
  224.         
  225.         foreach nm [array names prefDefs] {
  226.         global $nm
  227.         ensureNamespaceExists $nm
  228.         set $nm $prefDefs($nm)
  229.         }
  230.         catch {unset prefDefs}
  231.     }
  232.     
  233.     if {[file exists [file join $PREFS arrdefs.tcl]]} {
  234.         source [file join $PREFS arrdefs.tcl]
  235.         
  236.         foreach nm [array names arrprefDefs] {
  237.         set arr [lindex $nm 0]
  238.         set field [lindex $nm 1]
  239.         set val $arrprefDefs($nm)
  240.         global $arr
  241.         ensureNamespaceExists $arr
  242.         set ${arr}($field) $val
  243.         }
  244.         catch {unset arrprefDefs}
  245.     }
  246.     }
  247. } else {
  248.     proc prefs::readAll {} {
  249.     global PREFS
  250.         
  251.     if {[file exists [file join $PREFS defs.tcl]]} {
  252.         source [file join $PREFS defs.tcl]
  253.         
  254.         foreach nm [array names prefDefs] {
  255.         ensureNamespaceExists ::$nm
  256.         global ::$nm
  257.         set ::$nm $prefDefs($nm)
  258.         }
  259.         catch {unset prefDefs}
  260.     }
  261.     
  262.     if {[file exists [file join $PREFS arrdefs.tcl]]} {
  263.         source [file join $PREFS arrdefs.tcl]
  264.         
  265.         foreach nm [array names arrprefDefs] {
  266.         set arr [lindex $nm 0]
  267.         set field [lindex $nm 1]
  268.         set val $arrprefDefs($nm)
  269.         ensureNamespaceExists ::$arr
  270.         global ::$arr
  271.         set ::${arr}($field) $val
  272.         }
  273.         catch {unset arrprefDefs}
  274.     }
  275.     }
  276.  
  277. }
  278.  
  279.  
  280. proc prefs::tclRead {} {
  281.     global PREFS
  282.     # Use "prefs.tcl" to define or change any tcl information. 
  283.     if {![file exists [file join $PREFS prefs.tcl]]} {
  284.     if {![file exists "$PREFS"]} {
  285.         file mkdir "$PREFS"
  286.     }
  287.     close [open [file join $PREFS prefs.tcl] "w"]
  288.     }
  289.     uplevel #0 {
  290.     if {[catch {source [file join $PREFS prefs.tcl]}]} {
  291.         if {[dialog::yesno "An error occurred while loading \"prefs.tcl\".  Shall I make a trace on the error?"]} {
  292.         dumpTraces "prefs.tcl error" $errorInfo
  293.         }
  294.     }
  295.     }
  296. }
  297.  
  298.     
  299. proc prefs::viewSavedSetting {} {
  300.     global prefDefs arrprefDefs
  301.     
  302.     prefs::saveModified
  303.     
  304.     if {[catch {listpick -p "The following settings have been saved:" [prefs::listAllSaved]} res]} {
  305.     return
  306.     }
  307.     
  308.     if {[regexp {([^(]+)\(([^)]+)\)} $res "" arr field]} {
  309.     set arg [list $arr $field]
  310.     set val $arrprefDefs($arg)
  311.     } else {
  312.     global $res
  313.     set val $prefDefs($res)
  314.     }    
  315.     viewValue $res $val
  316.     catch {unset prefDefs}
  317.     catch {unset arrprefDefs}
  318. }
  319.  
  320. ## 
  321.  # -------------------------------------------------------------------------
  322.  # 
  323.  # "removeSavedSetting" --
  324.  # 
  325.  #  This proc shouldn't 'unset' the variables it removes, because most
  326.  #  such variables will be in use/have default values until restart.
  327.  # -------------------------------------------------------------------------
  328.  ##
  329. proc prefs::removeSavedSetting {} {
  330.     global prefDefs arrprefDefs
  331.     
  332.     prefs::saveModified
  333.     if {[catch {listpick -p "Remove which setting?" [lsort -ignore [prefs::listAllSaved]]} res]} {
  334.     return
  335.     }
  336.     
  337.     if {$res == ""} return
  338.     if {[regexp {([^(]+)\(([^)]+)\)} $res "" arr field]} {
  339.     global $arr
  340.     prefs::removeArrayElement $arr $field
  341.     } else {
  342.     global $res
  343.     prefs::remove $res
  344.     }
  345.     
  346.     catch {unset prefDefs}
  347.     catch {unset arrprefDefs}
  348. }
  349.  
  350.  
  351. proc prefs::listAllSaved {} {
  352.     global prefDefs arrprefDefs
  353.     
  354.     prefs::_read
  355.     prefs::_read arr
  356.     
  357.     set names [array names prefDefs]
  358.     foreach pair [array names arrprefDefs] {
  359.     lappend names "[lindex $pair 0]([lindex $pair 1])"
  360.     }
  361.     
  362.     return [lsort $names]
  363. }
  364.  
  365. #===============================================================================
  366.  
  367. proc prefs::tclEdit {} {
  368.     global PREFS
  369.     if {![file exists [file join $PREFS prefs.tcl]]} {
  370.     close [open [file join $PREFS prefs.tcl] "w"]
  371.     }
  372.     edit [file join $PREFS prefs.tcl]
  373. }
  374.  
  375. # Automatically add a line to the user input file
  376. proc prefs::tclAddLine {line} {
  377.     global PREFS
  378.     
  379.     if {![file exists "$PREFS"]} {
  380.     file mkdir "$PREFS"
  381.     }
  382.     set fid [alphaOpen [file join $PREFS prefs.tcl] "a+"]
  383.     if {![catch {seek $fid -1 end}]} {
  384.     if {![is::Eol [read $fid 1]]} {
  385.         set line "\r$line"
  386.     }
  387.     }
  388.     seek $fid 0 end
  389.     puts $fid $line
  390.     close $fid
  391. }
  392.  
  393. # Automatically add a line to a mode's pref file -trf
  394. proc prefs::tclAddModeLine {line} {
  395.     global PREFS mode
  396.     
  397.     if {![file exists "$PREFS"]} {
  398.     file mkdir "$PREFS"
  399.     }
  400.     set fid [alphaOpen [file join $PREFS ${mode}prefs.tcl] "a+"]
  401.     if {![catch {seek $fid -1 end}]} {
  402.     if {![is::Eol [read $fid 1]]} {
  403.         set line "\r$line"
  404.     }
  405.     }
  406.     seek $fid 0 end
  407.     puts $fid $line
  408.     close $fid
  409. }
  410.  
  411. proc prefs::saveNow {} {
  412.     global modifiedVars modifiedModeVars modifiedArrVars \
  413.       prefDefs modifiedArrayElements global::features \
  414.       alpha::earlyPrefs
  415.     
  416.     cache::delete configuration
  417.     cache::add configuration list global::features
  418.     
  419.     if {[info exists alpha::earlyPrefs]} {
  420.     foreach f [set alpha::earlyPrefs] {
  421.         global $f
  422.         if {[info exists $f]} {
  423.         cache::add configuration variable $f
  424.         }
  425.     }
  426.     } else {
  427.     set alpha::earlyPrefs {}
  428.     }
  429.     
  430.     foreach f [lunique $modifiedArrVars] {
  431.     prefs::addArray $f
  432.     }
  433.     foreach f [lunique $modifiedVars] {
  434.     if {[lsearch -exact [set alpha::earlyPrefs] $f] == -1} {
  435.         global $f
  436.         if {[array exists $f]} {
  437.         prefs::addArray $f
  438.         } else {
  439.         if {[info exists $f]} {
  440.             prefs::add $f [set $f]
  441.         } else {
  442.             prefs::remove $f
  443.         }
  444.         }
  445.     }
  446.     }
  447.     # these two lists actually behave identically
  448.     foreach f [concat [lunique $modifiedArrayElements]  [lunique $modifiedModeVars]] {
  449.     set elt [lindex $f 0]
  450.     set arr [string trimleft [lindex $f 1] :]
  451.     global $arr
  452.     if {[info exists [set arr]($elt)]} {
  453.         prefs::addArrayElement [set arr] $elt [set [set arr]($elt)]
  454.     } else {
  455.         prefs::removeArrayElement [set arr] $elt
  456.     }
  457.     }
  458.     message "Preferences saved"
  459. }
  460.  
  461. proc prefs::saveModified {} {
  462.     global modifiedVars modifiedModeVars modifiedArrVars \
  463.       modifiedArrayElements
  464.     prefs::saveNow
  465.     set modifiedVars {}
  466.     set modifiedArrVars {}
  467.     set modifiedModeVars {}
  468.     set modifiedArrayElements {}
  469. }
  470.  
  471.  
  472. #===============================================================================
  473.  
  474. namespace eval mode {}
  475.  
  476. ## 
  477.  # -------------------------------------------------------------------------
  478.  # 
  479.  # "mode::sourcePrefsFile" --
  480.  # 
  481.  #  Fixes 'uplevel #0' problem
  482.  # -------------------------------------------------------------------------
  483.  ##
  484. proc mode::sourcePrefsFile {} { 
  485.     global mode PREFS
  486.     if {[file exists [file join ${PREFS} ${mode}Prefs.tcl]]} {
  487.     uplevel #0 [list source [file join ${PREFS} ${mode}Prefs.tcl]]
  488.     } else {
  489.     beep; message "Sorry, no preferences file for '$mode' mode"
  490.     }
  491. }
  492.  
  493. proc mode::editPrefsFile {{m ""}} { 
  494.     global PREFS mode
  495.     if {$m == ""} { set m $mode }
  496.     message $m
  497.     # assume it is a mode, since we made the menu
  498.     
  499.     set f [file join $PREFS ${m}Prefs.tcl]
  500.     if {[file exists $f]} {
  501.     edit $f
  502.     } else {
  503.     if {[dialog::yesno "No '$m' prefs file exists, do you want to create one?"]} {
  504.         close [open $f "w"]
  505.         edit $f
  506.         insertText {
  507. ## 
  508.  # This    file will be sourced automatically, immediately after 
  509.  # the _first_ time the file which defines its mode is sourced.
  510.  # Use this file to insert your own mode-specific preferences
  511.  # and changes,    rather than altering the originals.
  512.  # 
  513.  # You can redefine menus, procedures, variables,...
  514.  ##
  515.  
  516.     }}}
  517.     
  518.     hook::callAll mode::editPrefsFile
  519. }
  520.  
  521.